perm filename MAPS2.SAI[SYS,HE]1 blob
sn#046692 filedate 1973-06-06 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00031 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00007 00002 MAPS2- the mapping of a prototype.
00011 00003 _ external procedures
00013 00004 _ MAPREC - following procedures are internal - PARGR, ANGDIF
00016 00005 _ UNCER
00019 00006 _ RECON
00022 00007 _ PREORB, NOASS
00024 00008 _ LFCHCK, CONDIV
00026 00009 _ PARUP
00029 00010 _ LENCLA
00032 00011 _ FUSE
00035 00012 _ CLEVER, SUMMA
00037 00013 _ DELREC
00040 00014 _ DELREC cont
00043 00015 _ PARCHK, EXTNDV
00045 00016 _ EXTNDL, CLEVA
00048 00017 _ SCORE
00052 00018 _ body of MAPREC begins here
00054 00019 _ MAPREC cont
00056 00020 _ MAPREC cont
00058 00021 _ MAPREC cont
00060 00022 _ MAPREC cont
00062 00023 _ MAPREC cont
00065 00024 _ MAPREC cont
00068 00025 _ MAPREC cont
00070 00026 _ MAPREC cont
00073 00027 _ MAPREC cont
00075 00028 _ MAPREC cont
00077 00029 _ MAPREC cont
00079 00030 _ MAPREC cont
00082 00031 _ MAPREC cont
00084 ENDMK
⊗;
COMMENT MAPS2- the mapping of a prototype.;
ENTRY MAPREC;
BEGIN "MAPS2"
DEFINE QC(I)="&"" I=""&CVS(I)",
QCO(I)="&"" I=""&CVOS(I)",
QCR(R)="&"" R=""&CVF(R)",
NOTHING="",
CL="'15&'12",
BL="'40",
QENP="EXTERNAL PROCEDURE",
QS="STRING",
QESP="EXTERNAL SIMPLE STRING PROCEDURE",
QI="INTEGER",
QR="REAL",
QRI="REFERENCE INTEGER",
QRR="REFERENCE REAL",
QEP="EXTERNAL SIMPLE PROCEDURE",
QEIP="EXTERNAL SIMPLE INTEGER PROCEDURE",
QERP="EXTERNAL SIMPLE REAL PROCEDURE",
QFOP="FORWARD INTERNAL SIMPLE PROCEDURE",
QFOIP="FORWARD INTERNAL SIMPLE INTEGER PROCEDURE",
QFORP="FORWARD INTERNAL SIMPLE REAL PROCEDURE",
_="COMMENT",
LOOP(I,J,K,L)="FOR I←J STEP L UNTIL K DO",
QTRC="IF DTRACE∨MAPTRC LAND '12000 THEN QTRCE",
DTRC="IF DTRACE∨MAPTRC LAND '10000 THEN DTRCE",
LINSET="DISW←1; DTRC(""LINSRT:""QC(IFREEL)); LINSRT",
SAFEX="SAFE";
EXTERNAL INTEGER PROT,PLIN,PVER,AD0,LNCS1,LNCS2,RAYS,CMPIND,DTRACE,RUL,
MDCTR,DISW,LFDBT,DEGSW,DEGABL,N1,N2,LNCRE0,IFREEL,IFREEV,MAXNOL,
FULREC,LNCRE1,LNCRE2,FTREV,MODIF,MAXPLS,MAPTRC;
EXTERNAL REAL RWIC,RMALS,RELLF,RMAP;
SAFEX EXTERNAL INTEGER ARRAY LEDG1,LEDG2,LCREDE,LFEAT,LVERCO,LINK,
PLINE,PLINEF[1:1];
SAFEX EXTERNAL REAL ARRAY XVCOR,YVCOR,XLCOR,YLCOR,RLEN,ANGARG[1:1];
INTEGER NDP, NDSC, NEWLP, NEWSV, NEWLSC, NL1, NL2, VPR, VSC;
INTERNAL INTEGER SCO, CMPL;
_ external procedures;
QEIP LESSFT(QI I,J);
QERP SIND(QR R);
QEIP BITS(QI I,J,K);
QERP COSD(QR R);
QEIP NEXTSV(QI I,J);
QEIP INREK(QR X,Y);
QEIP ISIGN(QI I,J);
QEIP LACT(QI I);
QERP ANGLIN(QI I,J);
QEIP LVOPP(QI I);
QERP SQRT(QR R);
QERP LDIST(QR X,Y; QI I);
QEIP KARN(QR X1,Y1,X2,Y2,X3,Y3,X4,Y4; QRR X,Y;
QRI IX1,IX2,IP1,IP2; QRR R1,R2; QI IC; QR WI);
QEP REKOP(QR X1,Y1,X2,Y2,WI; QRR RL);
QEIP LNFEAT(QI I);
QEP MALI(QI I; QR X1,Y1,X2,Y2);
QERP AMOD(QR R,S);
QERP SIGN(;QR R,S);
QEP WEIGHV(QI I; QRR X,Y,WE);
QEIP LINSRT(QI I,J; QR X1,Y1,X2,Y2; QI K,L);
QEIP LCRV(QI I);
QEIP LCRL(QI L);
QEP DTRCE(QS S);
QEP LINDL(QI L,I);
QEP QTRCE(QS S);
QEP MLCR(QI I,J);
QEP REVIVE(QI L);
QEP UPPDAL(QI I);
QEIP FUSABL(QI I,J,K,L);
QEIP LFDIF(QI I,J,K,L);
QEIP LVNEXT(QI I,J);
_ MAPREC - following procedures are internal - PARGR, ANGDIF;
_ Builds up mapping as far as it can, in explicitly programmed recursion.
Exits with 1 or 0 for success or failure, resp.;
INTERNAL INTEGER PROCEDURE MAPREC;
BEGIN "MAPREC"
LABEL RULS,BU,OU,OU0,BA0,BA1,BA2,ON1,MO,MO1,L1,L2,L3,L4,FUS,
NFUS,NINC,BAAU;
INTEGER IA,IB,ID,IC,IG,RAYCNT,IFR,BAUS,IBB,ICV0,RLEV,LMAP,V1,V2,
IRET,BAU,IBL,ICL,NVP,NVSC,VEMOD,MAPI,MPORD,ORIGLM,IDL,
INCOV,INCOVS,RAY,ICN,BULEVS,IAA,LNY,VL,INSUF,CMPLO,
CH,INS,MOBITS,PLND,NDSCM,NLSCM;
REAL WE,GA,DA,X,Y,X1,Y1,X2,Y2,RDIF,RP,RL;
SAFEX REAL ARRAY LENARG[0:PLIN,0:1,0:1],PARARG[0:PLIN],RRR,RNUM[0:1];
SAFEX INTEGER ARRAY MPORDS,MAPIS[1:2*PLIN],LFUSES[1:63],
LFUSE[1:PLIN,0:1],EVA[1:PLIN];
SAFEX EXTERNAL INTEGER ARRAY PVMAP,VLEV,MAPORD,PARCLA,LENCAT,INSLEV,
LFTSTL[1:1],LENDV,LENDP,PLMAP,PLMAPO,LLEV,LLEVO[1:1,0:1],
PARTS[1:63,0:1+MAXPLS%3];
FORWARD SIMPLE INTEGER PROCEDURE LENCLA(INTEGER PL,SVL,SV,ITRS);
_ Returns line // PBL, and in a pointer-relation to OTH (ie. //-gram).;
SIMPLE INTEGER PROCEDURE PARGR(INTEGER PBL,OTH);
BEGIN "PARGR"
INTEGER IA;
LOOP(IA,1,PLIN,1)
IF IA≠PBL
∧PARCLA[IA]=PARCLA[PBL]
∧(LENDP[OTH,0]=IA
∨LENDP[OTH,1]=IA
∨LENDP[IA,0]=OTH
∨LENDP[IA,1]=OTH)
THEN RETURN(IA);
RETURN(0)
END "PARGR";
_ return the least difference of angles a1 and a2 (directions ignored);
SIMPLE REAL PROCEDURE ANGDIF(REAL A1,A2);
RETURN(ABS(AMOD(ABS(A1-A2)+90.,180.)-90.));
_ UNCER;
_ Replaces intersection (if necessary and possible) so as to
satisfy LENCLA. Returns 0 for OK, -1 otherwise.;
SIMPLE INTEGER PROCEDURE UNCER;
BEGIN "UNCER"
LABEL BA,ON;
INTEGER IND,I,IO,PL,CV,IL;
REAL RA,RB,RC,RD,A1,A2,RD1,RD2,AD1,AD2,RP1,RP2;
IND←-2;
PL←IA;
CV←LVERCO[IC];
WHILE (IND←IND+1)≤0 DO
BEGIN
RA←RB;
RC←RD;
IO←I;
X1←X2;
Y1←Y2;
RD1←RD2;
RP1←RP2;
MALI(IFREEL,X,Y,X2←XVCOR[CV],Y2←YVCOR[CV]);
I←LENCLA(PL,IFREEL,0,0);
RP2←RP;
RD2←RDIF;
RB←(RD←RLEN[IFREEL])-(IF I=1∨I=-2 THEN
RDIF+SIGN(1.,RDIF) ELSE 0.);
PL←NEWLP;
CV←PVMAP[NVP]
END;
IF IO≠-2∧IO≠1∧I≠-2∧I≠1 THEN RETURN(0);
BA: IF ¬IO THEN
BEGIN
X←X2+(X-X2)*RB/RD;
Y←Y2+(Y-Y2)*RB/RD;
IF IND THEN RETURN(0) ELSE GO ON
END;
IF ¬I THEN
BEGIN
X←X1+(X-X1)*RA/RC;
Y←Y1+(Y-Y1)*RA/RC;
IF IND THEN RETURN(0) ELSE GO ON
END;
A1←PARARG[PARCLA[IA]];
A2←PARARG[PARCLA[NEWLP]];
AD1←ANGDIF(ANGARG[NLSCM],A1);
AD2←ANGDIF(ANGARG[(IG+1)%2],A2);
IND←ABS(AD1-AD2)<3.;
IL←(AD1<AD2
∧¬IND
∨IND
∧ABS(RLEN[NLSCM]/RP1-1.)<ABS(RLEN[(IG+1)%2]/RP2-1.));
IND←0;
IF IL THEN RA←0.5*(RP1+RA) ELSE
BEGIN RB←0.5*(RP2+RB); PL←IA END;
IO←1-(I←IL+1);
GO BA;
ON: MALI(IFREEL,X,Y,IF IL THEN X2 ELSE X1,IF IL THEN Y2 ELSE Y1);
IF (I←LENCLA(PL,IFREEL,0,0))=-1∨¬I THEN RETURN(0);
IF (V1←PARGR(IA,NEWLP))∧(V2←PARGR(NEWLP,IA)) THEN
BEGIN
A1←ANGARG[(PLMAP[V1,0]+1)%2];
A2←ANGARG[(PLMAP[V2,0]+1)%2]
END;
I←KARN(X1
,Y1
,X1+10.*COSD(A1)
,Y1+10.*SIND(A1)
,X2
,Y2
,X2+10.*COSD(A2)
,Y2+10.*SIND(A2)
,X,Y,V1,V2,IBL,ICL,GA,DA,1,RWIC);
RETURN(I≠1)
END "UNCER";
_ RECON;
_ Finds the (reconciliated) MODIF word for the current base-line.
If ¬RUL, returns the MODIF from first LFDIF call.
Otherwise searches the vertex for full lines, returning the
base-line adjusted first unambiguous MODIF, if any (otherwise
returns the first MODIF).;
SIMPLE PROCEDURE RECON;
BEGIN "RECON"
LABEL BA1,ON1;
INTEGER MOD1,CTR,SRAYS,MEWSV,MEWLP,MDP,MEWLSC,MDSC,MBTS,
DL,DI,DD,MSH,MDF;
MOD1←CTR←0;
MEWLP←NEWLP;
MDP←NDP;
MEWLSC←NEWLSC;
MDSC←NDSC;
BA1: LFDIF(PLINEF[AD0+MEWLP],LNFEAT(MEWLSC),MDP,
IF FTREV=1 THEN 1-MDSC ELSE MDSC);
IF ¬RUL∨¬MOD1∧MODIF≠-1∧MODIF LAND '200000000000 THEN RETURN;
IF ¬MOD1 THEN BEGIN MOD1←MODIF; SRAYS←RAYS END;
IF MODIF LAND '600000000000 THEN GO ON1;
IF ¬CTR THEN RETURN;
DL←DI←DD←0;
MSH←-2;
MDF←MODIF LSH (2-MDCTR);
WHILE DL+DI<CTR DO
BEGIN
MSH←MSH+2;
CASE (MBTS←(MDF←MDF LSH -2) LAND 3) OF
BEGIN DL←DL+1; DI←DI+1; DD←DD+1 END
END;
IF MBTS∨NEXTSV(NEWSV,DD+DL)≠MEWSV THEN GO ON1;
MODIF←MODIF LSH (34-MSH-MDCTR) LOR (MDF LSH -2) LSH MDCTR;
RAYS←SRAYS;
RETURN;
ON1: IF(MEWLP←LENDP[MEWLP,MDP])=NEWLP THEN
BEGIN MODIF←MOD1; RAYS←SRAYS; RETURN END;
CTR←CTR+1;
MDP←-(LENDV[MEWLP,0]≠VPR);
IF (MEWSV←PLMAP[MEWLP,1-MDP])
∧MEWSV≠'7777
∧LVERCO[MEWSV←LVOPP(MEWSV)]=VSC THEN
BEGIN
MEWLSC←(MEWSV+1)%2;
MDSC←1-(MEWSV LAND 1);
GO BA1
END ELSE GO ON1
END "RECON";
_ PREORB, NOASS;
_ Returns 0 iff the present vertex is not a consequence of full lines,
or INCOVS is on.;
SIMPLE INTEGER PROCEDURE PREORB;
BEGIN "PREORB"
INTEGER MEWLP,MDP,PLM,IRET;
IF INCOVS THEN RETURN(0);
MEWLP←NEWLP;
MDP←NDP;
IRET←0;
WHILE (MEWLP←LENDP[MEWLP,MDP])≠NEWLP DO
IF (PLM←PLMAP[MEWLP,1-(MDP←-(LENDV[MEWLP,0]≠VPR))])
∧PLM≠'7777
∧LVERCO[LVOPP(PLM)]=VSC
THEN IF (PLM←LLEV[MEWLP,MDP]<0)∨¬IRET THEN IRET←-1+PLM;
RETURN(IRET)
END "PREORB";
_ Returns 1 (else 0) iff there are no assumed rays hanging on to
current prototype line, IAA.;
SIMPLE INTEGER PROCEDURE NOASS;
BEGIN "NOASS"
INTEGER RAY,IB,IE;
LOOP(IB,0,1,1)
BEGIN
IE←IB;
RAY←IAA;
WHILE (RAY←LENDP[RAY,IE])≠IAA DO
BEGIN
IE←-(LENDV[RAY,0]≠LENDV[IAA,IB]);
IF PLMAP[RAY,IE]='7777 THEN RETURN(0)
END
END;
RETURN(1)
END "NOASS";
_ LFCHCK, CONDIV;
_ Returns 1 (else 0) iff untested complete lines are l.f.-consistent.;
SIMPLE INTEGER PROCEDURE LFCHCK;
BEGIN "LFCHCK"
INTEGER ISV,IRET;
LNCRE1←1001;
IRET←0;
LOOP(IAA,1,PLIN,1)
IF INSLEV[IAA]
∧¬LFTSTL[IAA]
∧NOASS THEN
IF LESSFT(PLINEF[AD0+IAA],LNFEAT(((ISV←PLMAP[IAA,1])+1)%2))
∨(ISV←ISV LAND 1)
∧FTREV=2
∨¬ISV
∧FTREV=1
THEN IRET←IAA ELSE LFTSTL[IAA]←RLEV;
LNCRE1←LNCS1;
DTRC("LFCHCK:"QC(IRET));
RETURN(¬IRET)
END "LFCHCK";
_ Returns (0,1,2) if outgoing line-pairs are (//&div,//&conv,neither).;
SIMPLE INTEGER PROCEDURE CONDIV(INTEGER PL);
BEGIN "CONDIV"
INTEGER IA,IB;
IA←BITS(IB←PLINEF[AD0+PL],3,4);
IB←BITS(IB,21,22);
RETURN(IF IA=1∨IB=1 THEN 1 ELSE IF IA=3∨IB=3 THEN 0 ELSE 2)
END "CONDIV";
_ PARUP;
_ Updates mean angular argument for parallelity class of prototype
line PL, weighting complete lines as two rays.;
SIMPLE PROCEDURE PARUP(INTEGER PL);
BEGIN "PARUP"
INTEGER IA,IB,IC,PARCL,CODIV;
REAL AVANG,NUM,D,B;
N1←LENCAT[PL];
NUM←AVANG←RRR[0]←RRR[1]←RNUM[0]←RNUM[1]←0.;
IF PARCL←PARCLA[PL] THEN
LOOP(IA,1,PLIN,1)
IF PARCLA[IA]=PARCL THEN
LOOP(IB,0,1,1)
IF (IC←PLMAP[IA,IB])
∧IC≠'7777
∧ABS LLEV[IA,IB]≠ABS LLEV[IA,1-IB] THEN
BEGIN
AVANG←AMOD(180.
+(NUM*AVANG+
(IF ABS(D←(B←AMOD(ANGARG[(IC+1)%2],180.))
-AVANG)>90. THEN
B-SIGN(180.,D) ELSE B))
/(NUM←NUM+1.)
,180.);
IF IB
∧(NL1←PVMAP[LENDV[IA,0]])
∧(NL2←PVMAP[LENDV[IA,1]])
∧N1=LENCAT[IA] THEN
BEGIN
RRR[CODIV←CONDIV(IA)]←RRR[CODIV]+
SQRT((XVCOR[NL1]-XVCOR[NL2])↑2+
(YVCOR[NL1]-YVCOR[NL2])↑2);
RNUM[CODIV]←RNUM[CODIV]+1.;
END
END;
PARARG[PARCL]←IF NUM THEN AVANG ELSE -1.;
LOOP(IA,0,1,1) RRR[IA]←RRR[IA]/(RNUM[IA] MAX 1.);
LOOP(IA,0,1,1)
LENARG[PARCL,IA,N1]←
IF RRR[IA] THEN RRR[IA] ELSE
RRR[1-IA]*(1.+RELLF*(0.5-IA))/(1.+RELLF*(1.-2.*IA));
DTRC("PARUP: "QC(PL)QC(PARCL)QCR(NUM)QCR(AVANG)
QCR(RNUM[0])QCR(RNUM[1])QCR(RRR[0])QCR(RRR[1]));
END "PARUP";
_ LENCLA;
_ Returns the following, depending on the relative size of line SVL
(if SV=0), or distance between the c.v:s of SVL and SV (if SV>0),
to length-class of PL:
-2 iff the line is too short.
-1 iff the line is acceptable.
0 iff there is no comparison, or no length-class.
1 iff the line is too long.
The program allows ITRS iterations, each time adjusting the length
by a factor 0.8 or 1.25, depending on perspective clues.;
SIMPLE INTEGER PROCEDURE LENCLA(INTEGER PL,SVL,SV,ITRS);
BEGIN "LENCLA"
LABEL OU,ITR;
INTEGER IRET,LCL,CAT,CODIV,N1,N2,LCR;
REAL RSC,ML;
IRET←0;
RSC←RP←0.;
ML←1.+RELLF;
IF ¬(LCL←PARCLA[PL]) THEN GO OU;
IF SV THEN BEGIN N1←SVL; N2←SV END ELSE N1←(N2←2*SVL)-1;
IF SV
∨(LCR←LCRL(SVL))≤1001
∧LCR>0 THEN
RSC←SQRT((XVCOR[N1←LVERCO[N1]]-XVCOR[N2←LVERCO[N2]])↑2+
(YVCOR[N1]-YVCOR[N2])↑2)
ELSE RSC←RLEN[SVL];
RP←LENARG[LCL,CODIV←CONDIV(PL),LENCAT[PL]];
IF ¬RP THEN GO OU;
ITR: IRET←IF (RDIF←RSC-ML*RP)>0. THEN 1 ELSE
IF (RDIF←RSC-RP/ML)<0. THEN -2 ELSE -1;
IF ITRS∧(IRET=-2∧¬CODIV∨IRET*CODIV=1) THEN
BEGIN
ITRS←ITRS-1;
IRET←0;
ML←ML*(1.+RELLF);
GO ITR
END;
OU: IF ¬IRET∨IRET=-1 THEN RDIF←RSC-RP;
DTRC("LENCLA:"QC(PL)QC(SVL)QC(SV)QC(LCL)QC(CAT)QCR(RSC)
QCR(RP)QCR(RDIF)QC(ITRS)QC(IRET));
RETURN(IRET)
END "LENCLA";
_ FUSE;
_ If possible fuses current scene-line and returns 1, else returns 0.
Treats pos. and neg. links alike.;
SIMPLE INTEGER PROCEDURE FUSE(INTEGER IC,IA,IB);
BEGIN "FUSE"
INTEGER N1,ICO,I1,I2,IL,ICV;
IAA←0;
IDL←ABS LINK[ICO←LVOPP(IC)];
IF IDL THEN
BEGIN
IAA←LENCLA(IA,IC,N1←LVOPP(IDL),1);
DA←ANGLIN(V2←(IC+1)%2,V1←(IDL+1)%2)
END;
DTRC("FUSE: "QC(IC)QC(IA)QC(IB)QC(IDL)QCR(DA));
IF ¬IDL∨LCRV(IDL)>1000∨IAA=1∨DA>RMAP THEN RETURN(0);
ICV←LVERCO[IC];
_ Check for INCOV-passage.;
I1←IA;
I2←IB;
WHILE (I1←LENDP[I1,I2])≠IA DO
BEGIN
I2←-(LENDV[IA,IB]≠LENDV[I1,0]);
IF (IL←(PLMAP[I1,1-I2]+1)%2)
∧IL≠'4000
∧LEDG1[IL]>0
∧LDIST(XVCOR[VSC],YVCOR[VSC],IL)
/LDIST(XVCOR[ICV],YVCOR[ICV],IL)
<-2.*RELLF
THEN BEGIN DTRC("INCOV-pass");RETURN(0) END
END;
_ There is a link to an unused line. Fuse the lines, i.e.
insert a compound line.;
_ VERTEX PASSAGE TEST EXPERIMENTALLY SKIPPED
LEDG1[IFREEL]← IF LCRL(V2)=1002
∧LEDG1[V2]=4
∨((ICO←NLINCV(I1←LVERCO[ICO]))≥3
∨NLINCV(I2←LVERCO[IDL])≥3)
∧I1≠I2
∨I1=I2
∧ICO≥4 THEN 4 ELSE 3;
VSC←LVERCO[N1];
LEDG1[IFREEL]←3;
MLCR(V1,1003);
MLCR(V2,1003);
QTRC(CL&"Fusion: "&CVS(V2)&" + "&CVS(V1)&" → "&CVS(IFREEL));
PLMAP[IA,1-IB]←(NEWSV←2*(NEWLSC←IFREEL))-1;
LINSET(ICV,VSC,XLCOR[IC],YLCOR[IC],XLCOR[N1],YLCOR[N1],1002,0);
LOOP(IG,1,63,1) IF ¬LFUSES[IG] THEN
BEGIN
_ First unused LFUSES-word. Store here.;
LFUSES[IG]←IC LSH 12 LOR (NEWSV-1);
DONE
END;
IF LINK[NEWSV]←LINK[N1] THEN LINK[LINK[N1]]←NEWSV;
LFUSE[IA,IB]←LFUSE[IA,IB] LSH 6 LOR IG;
NDP←1;
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
RETURN(1)
END "FUSE";
_ CLEVER, SUMMA;
_ If SW=1, inactivates unused scene-lines at vertex ICV (LCREDE←ILCR).
If SW=0, Revives inactivated (LCREDE=ILCR) lines at vertex ICV.;
SIMPLE PROCEDURE CLEVER(INTEGER ICV,ILCR,SW);
BEGIN "CLEVER"
IF SW THEN LNCRE1←LNCRE2←ILCR ELSE LNCRE2←1000;
ICV0←LVNEXT(ICV,9);
WHILE ICV0 DO
BEGIN
IF SW THEN REVIVE((ICV0+1)%2) ELSE MLCR((ICV0+1)%2,ILCR);
ICV0←LVNEXT(0,9)
END;
LNCRE1←LNCS1;
LNCRE2←1002
END "CLEVER";
_ Computes the number of mapped elements with characteristics as
described by the mask.;
SIMPLE INTEGER PROCEDURE SUMMA(INTEGER MSK);
BEGIN "SUMMA" INTEGER IA,IB;
IB←0;
LOOP(IA,1,PLIN,1) IF EVA[IA] LAND MSK = MSK THEN IB←IB+1;
IF IB THEN DTRC("SUMMA: "QCO(MSK)QC(IB));
RETURN(IB)
END "SUMMA";
_ DELREC;
_ Deletes results at present recursion level.;
SIMPLE INTEGER PROCEDURE DELREC(INTEGER SW);
BEGIN "DELREC"
LABEL BA1;
INTEGER IA,IB,IC,LID,LID2,IAS,IBS,VF,LEV,RLB,BASL,INSLS,VL,L2;
DTRC("DELREC: "QC(RLEV)QC(SW)QC(BULEVS));
BA1: MPORD←MPORDS[RLEV]+1;
IAS←RLB←0;
VL←-5;
IF RLEV<4 THEN RETURN(1);
LOOP(IA,1,PVER,1) IF ABS VLEV[IA] =RLEV THEN
BEGIN
CLEVER(PVMAP[IA],1007,1);
PVMAP[IA]←VLEV[IA]←0;
DONE
END;
LOOP(IA,1,PLIN,1)
LOOP(IB,0,1,1)
IF ABS(LEV←LLEV[IA,IB])=RLEV
∧(LEV>0
∨LEDG1[LID2←(PLMAP[IA,1-IB]+1)%2]≥0) THEN
BEGIN
L2←LEDG2[LID←(PLMAP[IA,IB]+1)%2];
VF←LFUSE[IA,IB];
PLMAP[IA,IB]←LLEV[IA,IB]←0;
IF LID∧LEDG1[LID]=-1 THEN
BEGIN
DTRC("DEL. INS. RAY"QC(IA));
LINDL(LID,LINK[2*LID]←0);
LLEV[IA,1-IB]←0;
DONE
END;
IF (INSLS←INSLEV[IA])>0 THEN
BEGIN
IF (IC←((PLMAP[IA,1-IB]←PLMAPO[IA,1-IB])+1)%2)∧
IC≠'4000 THEN REVIVE(IC);
IF (IC←PLMAPO[IA,IB])∧IC≠'7777 THEN REVIVE((IC+1)%2);
LLEV[IA,IB]←LLEVO[IA,IB];
LINDL(LID,0)
END ELSE
IF LID≠'4000∧¬INSLS∧¬VF∧LEV>0 THEN REVIVE(LID);
LFTSTL[IA]←INSLEV[IA]←0;
IF LEV<0 THEN
IF ¬VF THEN
IF ¬BULEVS∧¬FULREC THEN
BEGIN RLEV←RLEV-1;
DTRC("NEG RAY"QC(IA)&" BU TO"QC(RLEV));
GO BA1
END ELSE NOTHING ELSE BEGIN
_ DELREC cont;
_ We have the case of a compound line.
Unfuse last step - restore
constituents.
If BULEVS>0, back up all fuses;
WHILE VF DO
BEGIN
V1←VF LAND '77;
VF←LFUSE[IA,IB]←LFUSE[IA,IB] LSH -6;
V2←LFUSES[V1] LAND '7777;
IC←PLMAP[IA,1-IB]←LFUSES[V1] LSH -12;
LFUSES[V1]←0;
IDL←ABS LINK[LVOPP(IC)];
IF IG←LINK[V1←LVOPP(IDL)] THEN
LINK[ABS IG]←ISIGN(V1,IG)+
(LINK[LVOPP(V2)]←0);
REVIVE(IC←(IC+1)%2);
REVIVE(IDL←(IDL+1)%2);
LINDL(V2←(V2+1)%2,0);
QTRC(CL&"Un-fusion: "&CVS(V2)&" → "&
CVS(IC)&" + "&CVS(IDL)&
" Same"QC(RLEV));
IF ¬BULEVS THEN
BEGIN
LLEV[IA,IB]←LEV;
RLB←1;
MAPIS[RLEV]←MAPIS[RLEV-1];
DONE
END
END
END ELSE BEGIN
IF ¬(BASL←MAPORD[MPORDS[LEV]]=IA)∧INSLS<0
THEN LLEV[IA,IB]←LLEVO[IA,IB]+(VL←0);
IF BASL THEN BEGIN IAS←IA; IBS←IB END ELSE
IF L2<0 THEN VL←0
END;
IF SW THEN PARUP(IA);
DONE
END;
IF ¬BULEVS∧IAS∧SW THEN IF VL THEN MPORD←MPORD-(BAUS←1) ELSE
IF ¬VL THEN
BEGIN
RLEV←RLEV-(SW←1);
DTRC("VERTEX-BU"QC(RLEV));
GO BA1
END;
RLEV←RLEV+RLB;
MAPI←MAPIS[RLEV-1];
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
RETURN(0)
END "DELREC";
_ PARCHK, EXTNDV;
_ Returns 1 (else 0) iff the current mapping is an acceptable partial.;
SIMPLE INTEGER PROCEDURE PARCHK;
BEGIN "PARCHK"
INTEGER IA,IB,IC,IAA,N1;
_ Check for incovs.;
LOOP(IA,1,PVER,1)
IF ¬PVMAP[IA] THEN
BEGIN
IAA←-1;
LOOP(IB,1,PLIN,1)
LOOP(IC,0,1,1)
IF LENDV[IB,IC]=IA
∧(N1←PLMAP[IB,1-IC])
∧N1≠'7777
∧(IAA←IAA+1) THEN RETURN(0)
END;
_ Check for fused rays.;
LOOP(IB,1,PLIN,1)
LOOP(IC,0,1,1)
IF ¬PLMAP[IB,IC]
∧(IA←(PLMAP[IB,1-IC]+1)%2)
∧IA≠'4000
∧LCRL(IA)=1002
∧LEDG1[IA]≥0 THEN RETURN(0);
RETURN(1)
END "PARCHK";
_ Returns -1 iff s.v. ISV has a connected extension to an unused line.;
SIMPLE INTEGER PROCEDURE EXTNDV(INTEGER ISV);
RETURN((ICV0←LINK[ISV])>0∧LCRV(ICV0)<1001∧LVERCO[ISV]=LVERCO[ICV0]);
_ EXTNDL, CLEVA;
_ Returns -1 iff line IL has a connected extension to an unused line.;
SIMPLE INTEGER PROCEDURE EXTNDL(INTEGER IL);
RETURN(EXTNDV(2*IL)∨EXTNDV(2*IL-1));
_ Sets classification bits for prototype line PL.;
SIMPLE PROCEDURE CLEVA;
BEGIN "CLEVA"
INTEGER CLEV,IA,IB,IC,IL;
LOOP(IA,1,PLIN,1)
BEGIN
CLEV←4;
LOOP(IB,0,1,1)
IF IC←(PLMAP[IA,IB]+1)%2 THEN
IF PLMAP[IA,1-IB] THEN
BEGIN "LINE"
IL←LEDG1[IC];
CLEV←(IF LCRL(IC)=1001 THEN '11 ELSE '21
LOR (IF IL≤0 THEN '400 ELSE
IF IL<3 THEN '200 ELSE '100))
LOR (IF LFTSTL[IA] THEN '1000 ELSE
'2000)
LOR (IF LEDG2[IC]=-2
∨LCRL(IC)=1001
∧EXTNDL(IC) THEN '10000 ELSE
IF IL THEN '20000 ELSE 0)
LOR (IF LCRL(IC)=1002 THEN
IF IL=4 THEN '200000000 ELSE
IF IL=3 THEN '100000000
ELSE 0
ELSE 0);
DONE
END "LINE" ELSE BEGIN "RAY"
CLEV←(IF IC='4000 THEN '42 ELSE
IF LCRL(IC)=1001 THEN '12 ELSE '22 LOR
(IF LEDG1[IC]≥0 THEN '100000 ELSE
'200000));
DONE
END "RAY";
EVA[IA]←CLEV LOR (IF PARCLA[IA] THEN '1000000 ELSE '2000000)
LOR (IF PLINE[AD0+IA] LAND '6000 THEN '10000000
ELSE '20000000)
END
END "CLEVA";
_ SCORE;
_ Computes score for a mapping. Also determines whether it is
sufficient and (if so) whether it is complete.;
SIMPLE PROCEDURE SCORE;
BEGIN "SCORE"
INTEGER NB,N3;
INSUF←CMPL←SCO←0;
IF SUMMA(1)<3
∨SUMMA('11)+SUMMA('100)<2
THEN BEGIN INSUF←1; RETURN END;
SCO← SUMMA('1000) LSH 22
+ (SUMMA('21010)
+ SUMMA('100021100)
+ SUMMA('21200)) LSH 20
+ (SUMMA('10021010)
+ SUMMA('110021100)
+ SUMMA('10021200)) LSH 19
+ (SUMMA('10021010)
+ SUMMA('110021100)) LSH 18
+ SUMMA('10021200) LSH 17
+ (SUMMA('10022010)
+ SUMMA('110022100)) LSH 16
+ SUMMA('10022200) LSH 15
+ (SUMMA('20021010)
+ SUMMA('120021100)) LSH 14
+ SUMMA('20021200) LSH 13
+ (SUMMA('20022010)
+ SUMMA('120022100)) LSH 12
+ SUMMA('20022200) LSH 11
+ (SUMMA('10001400)
+ SUMMA('10011000)) LSH 10
+ (SUMMA('10002400)
+ SUMMA('10012000)) LSH 9
+ (SUMMA('20001400)
+ SUMMA('20011000)) LSH 8
+ (SUMMA('20002400)
+ SUMMA('20012000)) LSH 7
+ (SUMMA('10000012)
+ SUMMA('10100000)) LSH 6
+ (SUMMA('20000012)
+ SUMMA('20100000)) LSH 5
+ SUMMA('10200000) LSH 4
+ SUMMA('20200000) LSH 3;
NB←SUMMA('10000000);
CMPL← SUMMA('1000)=PLIN
∧(N3←SUMMA('10020100)
+SUMMA('10020200)
+SUMMA('10020011))≥NB-1
∧(N3=NB∨SUMMA('11000400)=1)
∧SUMMA('20000400)≤1
∧SUMMA('10020200)+SUMMA('10000400)+SUMMA('10010000)≤6;
IF CMPL∧N3<NB THEN CMPL←1;
_ SKIP VERTEX TEST FOR THE TIME BEING;
IF CMPL∧SUMMA('400)=20 THEN
BEGIN
LOOP(N3,1,PLIN,1)
IF EVA[N3] LAND '400 = '400 THEN
BEGIN
CMPL←NB;
NB←LENDV[N3,0] LSH 18 + LENDV[N3,1]
END;
CMPL←(N3←CMPL XOR NB)>'777777
∧N3 LAND '777777
∧(N3←CMPL XOR NB ROT 18)>'777777
∧N3 LAND '777777
END;
DTRC("SCORE:"QC(SCO)QC(CMPL))
END "SCORE";
_ body of MAPREC begins here;
MAPI←MPORD←ORIGLM←1;
RUL←BULEVS←BAU←BAUS←CMPL←CMPLO←0;
IRET←-1;
LNCRE0←1001;
LNCRE2←1002;
RLEV←2;
DEGSW←IF PROT≤2∧DEGABL THEN 2 ELSE 0;
LOOP(IA,0,PLIN,1) PARARG[IA]←-1.;
LOOP(IA,1,PLIN,1) INSLEV[IA]←LFTSTL[IA]←0;
QTRC(CL&"F-mappings"&CL);
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
_ Find mappings according to current rule (F=0 or C=1) for all
unmapped end-vertices of previously mapped lines.;
_ * * * * * CENTRAL LOOP BEGINS * * * * *;
RULS: LOOP(ID,MPORD,MAPI,1) LOOP(IBB,0,1,1)
BEGIN
IB←IBB XOR LFDBT;
DTRC("LOOP: "QC(ID)QC(IB));
IF ¬PVMAP[VPR←LENDV[IA←MAPORD[ID],IB]] ∧
ABS LLEV[IA,IB] ≠ RLEV-1 THEN
BEGIN "LP1"
INCOVS←0;
BAU←BAUS;
BAUS←VL←0;
BA0: NDP←IB;
NEWLP←IA;
INS←RAY←CH←RAYCNT←0;
NLSCM←NEWLSC←((IC←PLMAP[IA,1-IB])+1)%2;
NDSCM←NDSC←IC LAND 1;
VSC←LVERCO[PLND←NEWSV←LVOPP(IC)];
DTRC(":BA0:"QC(IA)QC(IB)QC(VPR)QC(NEWLP)QC(NDP)
QC(IC)QC(NLSCM)QC(NDSCM)QC(NEWSV)QC(VSC));
IF BAU THEN GO BAAU;
_ In the case of a backing-up ray go and check
if there is an intersection consequence vertex.;
IF INCOV←(LLEV[IA,IB] MIN 0) THEN GO BA1;
_ MAPREC cont;
_ Check that the c.v. has no contradictory use.;
LOOP(IG,1,PVER,1) IF PVMAP[IG]=VSC THEN
BEGIN
BULEVS←RLEV-1-
(LLEV[IA,1-IB] MAX ABS VLEV[IG]);
DTRC("C.V. CONTRAD."QC(BULEVS));
GO BU
END;
IF ¬BAU THEN
BEGIN
_ Not backup case. Find LFDIF and treat vertex
accordingly.;
BA2: DTRC(":BA2: "QC(RUL)QC(INCOVS));
IF LEDG1[NEWLSC]=-1 THEN
BEGIN
DTRC("RAY - TRY FUSION");
GO FUS
END;
_ Pre-orbit scan.;
IF (VL←PREORB)=-2 THEN GO NFUS;
IF (IAA←LENCLA(NEWLP,NEWLSC,0,1))=-2 THEN
BEGIN
DTRC("SHORT - TRY FUSION?");
IF ¬RUL THEN DONE ELSE GO NINC
END;
IF IAA=1 THEN
BEGIN
DTRC("LONG - BACK UP?");
IF ¬RUL THEN DONE ELSE
NINC: IF ¬INCOVS THEN IF VL∨IAA=1 THEN
GO NFUS ELSE GO FUS ELSE
BEGIN
DELREC(0);
DTRC("F-INCOV");
GO BU
END
END;
_ Find vertex modification code (MODIF).;
RECON;
IF ¬RUL∧MODIF∧RLEV≥4 THEN DONE;
VEMOD←MODIF LSH 2;
_ MAPREC cont;
_ If we can do nothing with the vertex,
try fusion.;
IF MODIF LAND '600000000000 THEN
IF INCOVS THEN
BEGIN
DTRC("INCOV NO GOOD");
DELREC(0);
DONE
END ELSE GO FUS
END ELSE BEGIN
BAAU: DTRC("BAU ON");
BAU←0;
FUS: IF ¬VL∧FUSE(IC,IA,IB) THEN GO BA0 ELSE
BEGIN
_ No fusion. Check for an
intersection consequence vertex.
If none, nothing else to do but
leave as a ray.;
NFUS: INCOV←-1;
LLEV[IA,IB]←-RLEV;
MPORDS[RLEV]←ID;
MAPIS[RLEV]←MAPIS[RLEV-1];
DTRC("BACK RAY"QC(RLEV));
RLEV←RLEV+1
END
END;
BA1: _ Treat next prototype line around current vertex.;
DTRC(":BA1:");
IF (NEWLP←LENDP[NEWLP,NDP])=IA THEN GO ON1;
NDP←-(LENDV[NEWLP,0]≠VPR);
NVP←LENDV[NEWLP,1-NDP];
IF INCOV THEN
BEGIN
DTRC(":"QC(INCOV));
IF LLEV[NEWLP,NDP]≥0 THEN GO BA1;
_ MAPREC cont;
_ The other line is backing up.;
DTRC("TRY INTERSECTION");
V1←KARN(XLCOR[IC],YLCOR[IC]
,XLCOR[IG←LVOPP(IC)]
,YLCOR[IG]
,XLCOR[IG←PLMAP[NEWLP,1-NDP]]
,YLCOR[IG]
,XLCOR[V2←LVOPP(IG)]
,YLCOR[V2]
,X,Y,V1,V2,IBL,ICL,GA,DA,1,RWIC);
L4: IF ¬V1∨IBL=1∨ICL=1∨IBL=-1∧GA<5.∨ICL=-1∧DA<5.
THEN BEGIN
BULEVS←RLEV-1-(LLEV[NEWLP,1-NDP]
MAX LLEV[IA,1-IB]);
DTRC("-FAULT"QC(BULEVS));
GO BU
END;
_ Use uncertainty to adjust intersection if
necessary.;
IF UNCER THEN
BEGIN
DTRC("F-INC-LEN");
GO BU
END;
_ Intersection seems OK. Create and orbit the
new vertex.;
LLEVO[NEWLP,NDP]←LLEV[NEWLP,NDP];
LLEVO[IA,IB]←LLEV[IA,IB];
INSLEV[IA]←INSLEV[NEWLP]←LLEV[NEWLP,NDP]←
LLEV[IA,IB]←RLEV;
MLCR(IAA←(IG+1)%2,1003);
PLMAPO[NEWLP,1-NDP]←IG;
PLMAP[NEWLP,1-NDP]←
(PLMAP[NEWLP,NDP]←2*IFREEL)-1;
V2←IFREEV;
IFR←IFREEL;
LINSET(ICV0←PVMAP[NVP],0,XVCOR[ICV0],
YVCOR[ICV0],X,Y,1002,0);
RL←SQRT((XLCOR[IG←LVOPP(IG)]-XVCOR[ICV0])↑2+
(YLCOR[IG]-YVCOR[ICV0])↑2);
LEDG2[IFR]←(EXTNDV(IG)∨RLEN[IFR]-RL+
RMALS<0.)-1;
_ MAPREC cont;
IF LEDG1[IAA]≥0
∧(ABS(LDIST(XLCOR[IG],YLCOR[IG],IFR))
*RLEN[IFR]
/RL<1.8*RWIC
∨LEDG2[IFR]=-2) THEN LEDG1[IFR]←1;
MLCR(NEWLSC,1003);
PLMAPO[IA,1-IB]←IC;
PLMAP[IA,1-IB]←(PLMAP[IA,IB]←2*IFREEL)-1;
IFR←IFREEL;
LINSET(ICV0←LVERCO[IC],V2,XVCOR[ICV0],
YVCOR[ICV0],0.,0.,1002,0);
RL←SQRT((XLCOR[PLND]-XVCOR[ICV0])↑2+
(YLCOR[PLND]-YVCOR[ICV0])↑2);
LEDG2[IFR]←(EXTNDV(IC)∨RLEN[IFR]-RL+
RMALS<0.)-1;
IF LEDG1[NEWLSC]≥0
∧(ABS(LDIST(XLCOR[PLND],YLCOR[PLND],IFR))
*RLEN[IFR]
/RL<1.8*RWIC
∨LEDG2[IFR]=-2) THEN LEDG1[IFR]←1;
PLMAPO[NEWLP,NDP]←PLMAPO[IA,IB]←0;
INCOVS←1;
IF MAPTRC LAND 1 THEN UPPDAL(MAPTRC LAND 2);
_ Note that MAPORD-entry is not needed here.;
_ Now continue with this created vertex
at the same recursive level.;
GO BA0
END;
MO: DTRC(":MO: "QC(INS));
IF ¬INS THEN
BEGIN
_ There is no insertion at this position, so find
mapping information for next scene-line.;
MO1: NEWLSC←((NEWSV←NEXTSV(NEWSV,1))+1)%2;
NDSC←1-(NEWSV LAND 1);
NVSC←LVERCO[LVOPP(NEWSV)];
IF INS THEN GO L1
END;
_ MAPREC cont;
_ See if current scene-line should be
used, preceded by an insertion, or skipped.;
MOBITS←BITS(VEMOD,34,35);
VEMOD←VEMOD LSH 2;
INS←0;
DTRC(" "QC(MOBITS)QCO(VEMOD));
CASE MOBITS OF BEGIN NOTHING; INS←1; GO MO END;
QTRC(CL&"BASE="&CVS(IA)&" NEWLP="&CVS(NEWLP)&
" NEWSV="&CVS(NEWSV)&" INS="&CVS(INS));
_ Check that this scene-line has no contradictory use.;
IF ¬INS THEN
LOOP(IG,1,PLIN,1)
IF IG≠NEWLP THEN
LOOP(IDL,0,1,1)
IF(PLMAP[IG,IDL]+1)%2=NEWLSC THEN
BEGIN
DTRC("CONTR. USE"QC(NEWLP)
QC(NEWLSC));
VL←1;
GO OU0
END;
_ Also check that the ray does not deviate drastically
from the general direction of its parallelity-class.
If it does, back up if ray is mapped at the other end -
otherwise replace it by an inserted ray. Save LLEV for
full original lines, mapped at the other end.;
IF ¬INS
∧(X←PARARG[PARCLA[NEWLP]])>-0.5
∧ ANGDIF(ANGARG[NEWLSC],X)>RMAP THEN
BEGIN
DTRC("F-ANGLE");
IF (PLMAP[NEWLP,1-NDP]+1)%2≠NEWLSC∧RUL THEN
BEGIN INS←1; GO MO1 END ELSE
BEGIN VL←1; GO OU0 END
END;
L1: LMAP←((ICN←PLMAP[NEWLP,1-NDP])+1)%2;
DTRC(":L1:"QC(LMAP));
_ MAPREC cont;
IF LMAP THEN
IF LMAP=NEWLSC∧¬INS THEN
IF ¬INCOVS THEN
LLEVO[NEWLP,NDP]←LLEV[NEWLP,NDP]
ELSE NOTHING
ELSE IF INS∧LMAP='4000 THEN NOTHING
ELSE IF (IF INS∨LMAP='4000 THEN
FUSABL(IF INS THEN ICN ELSE NEWSV
,-INS,PVMAP[NVP],VSC)
ELSE FUSABL(1,1,LVOPP(ICN)
,LVOPP(NEWSV)))
THEN NOTHING ELSE
BEGIN
QTRC(CL&"///-test failed");
OU0: DTRC(":OU0:");
IF DELREC(0) THEN GO OU;
BAU←1;
IF INCOVS THEN GO BU ELSE GO BA0
END;
_ At this point the other end is either unmapped
or the two mappings are identical or seem to
satisfy a ///-relationship.;
L2: CH←1;
RAY←RAY+1;
IF ¬INS THEN RAYCNT←RAYCNT+1;
IF ¬LMAP THEN
BEGIN
_ No mapping at other end. Just enter
(possibly insert) ray (or enter token,
if direction is not given).;
IG←0;
PLMAP[NEWLP,NDP]←
IF ¬INS THEN NEWSV ELSE
IF(WE←PARARG[PARCLA[NEWLP]])=-1.
THEN '7777 ELSE 2*IFREEL-(IG←1);
_ NOTE that here would be the logical place
to check incov:s for the new ray. However,
I predict that cases of intersection faults
will be rare enough to bias the trade-off in
favour of saving the check until rays are
backing up.;
_ MAPREC cont;
_ Insert the ray, physically? If so, also mark
it as backing up.;
IF IG THEN
BEGIN
DTRC("INSERTING RAY"QC(IFREEL)
QC(RAY)QC(RAYS));
LEDG1[IFREEL]←-1;
_ Find closest collinear active line.;
X1←(X2←XVCOR[VSC])
+5.*COSD(DA←WE-180.
*((GA←AMOD(WE
-ANGARG[NLSCM]
-180.*NDSCM+720.
,360.))≥180.
∧RAY≤RAYS
∨RAY>RAYS∧GA≤180.));
Y1←(Y2←YVCOR[VSC])+5.*SIND(DA);
LNY←IFREEL;
LINSET(VSC,0,0.,0.,X1,Y1,1002,0);
WE←900000.;
IAA←0;
LOOP(V1,1,MAXNOL,1)
IF V1≠LNY
∧LACT(V1)
∧ANGLIN(LNY,V1)<RMAP THEN
BEGIN
IF (X2-XLCOR[V2←2*V1-1])↑2
+(Y2-YLCOR[V2])↑2
<+(X2-XLCOR[V2+1])↑2
+(Y2-YLCOR[V2+1])↑2
THEN V2←V2+1;
REKOP(X2+0.4*(X2-X1)
,Y2+0.4*(Y2-Y1)
,XLCOR[V2]
,YLCOR[V2],RWIC,DA);
IF INREK(X1,Y1)
∧INREK(XLCOR[V2←LVOPP(V2)]
,YLCOR[V2])
∧(DA←(X1-XLCOR[V2])↑2
+(Y1-YLCOR[V2])↑2)<WE
THEN BEGIN IAA←V2; WE←DA END
END;
LINK[2*LNY]←IAA;
_ MAPREC cont;
_ NOTE: The other line is not linked up, in
order not to complicate existing links in
the scene. So such links must be zero-ed
before such rays are deleted.;
LLEV[NEWLP,1-NDP]←IF IAA THEN 0 ELSE -RLEV
END
END ELSE BEGIN
_ There is an entry at the other end. If same line,
just update PLMAP, otherwise enter and insert a
compound line to replace (temporarily) the other ray.
It will replace the current ray only if the ray is
physical.;
IG←0;
X1←Y1←X2←Y2←0.;
PLMAP[NEWLP,NDP]←IF LMAP=NEWLSC∧¬INS THEN NEWSV
ELSE 2*IFREEL-(IG←1);
IF IG THEN
BEGIN
_ Note that MAPORD-entry is not needed here.;
PLMAPO[NEWLP,1-NDP]←ICN;
INSLEV[NEWLP]←RLEV;
IF LMAP≠'4000 THEN MLCR(LMAP,1003);
PLMAP[NEWLP,1-NDP]←2*IFREEL;
LLEVO[NEWLP,NDP]←LLEV[NEWLP,NDP];
IAA←LMAP≠'4000∧LEDG1[LMAP]≥0;
IF ¬INS∧¬IAA THEN
BEGIN
X1←XLCOR[NEWSV];
Y1←YLCOR[NEWSV];
X2←XLCOR[V1←LVOPP(NEWSV)];
Y2←YLCOR[V1]
END;
IF INS∧IAA THEN
BEGIN
X1←XLCOR[V1←LVOPP(ICN)];
Y1←YLCOR[V1];
X2←XLCOR[ICN];
Y2←YLCOR[ICN]
END;
IF ¬INS∧IAA THEN
BEGIN
X1←XLCOR[NEWSV];
Y1←YLCOR[NEWSV];
X2←XLCOR[ICN];
Y2←YLCOR[ICN]
END;
_ MAPREC cont;
IF ¬INS THEN MLCR(NEWLSC,1003);
PLMAPO[NEWLP,NDP]←IF INS THEN 0 ELSE NEWSV;
LEDG2[IFREEL]←
(IAA∧EXTNDV(ICN)∨¬INS∧EXTNDV(NEWSV))-1;
LEDG1[IFREEL]←(1-INS) LSH 1 LOR (-IAA);
LINSET(VSC,PVMAP[NVP],X1,Y1,X2,Y2,1002,0)
END ELSE
IF ¬INSLEV[NEWLP] THEN INSLEV[NEWLP]←-RLEV
END;
LLEV[NEWLP,NDP]←RLEV;
_ Check length of new line if other end is mapped.;
IF LMAP∧((IAA←LENCLA(NEWLP
,PLMAP[NEWLP,NDP]
,PLMAP[NEWLP,1-NDP],1))
=-2∨IAA=1) THEN
BEGIN QTRC("F-LENGTH"QC(NEWLP)); GO OU0 END;
_ The ray will partake in future mappings if the other
end is unmapped and the ray is physical.;
L3: IF ¬LMAP∧(IG∨¬INS) THEN
BEGIN
MAPORD[MAPI←MAPI+1]←NEWLP;
IF ¬IG∧LCRL(NEWLSC)≠1002 THEN
MLCR(NEWLSC,1001)
END;
_ Take next line at current prototype vertex.;
IF (IG∨¬INS)∧MAPTRC LAND 1 THEN
UPPDAL(MAPTRC LAND 2);
GO BA1;
ON1: DTRC(":ON1:"QC(CH)QC(INCOV));
IF INCOV∧LLEV[IA,IB]=1-RLEV THEN
BEGIN MPORD←2; GO RULS END;
IF CH THEN
BEGIN
_ First bareness check...;
IF ¬RAYCNT THEN
BEGIN
QTRC("Bare"&CL);
GO OU0
END;
_ MAPREC cont;
_ Test l.f. consistency for completed lines.
Backup if test fails. Otherwise update
arrays.;
INS←0;
IF PVMAP[LENDV[IA,1-IB]]∧¬INSLEV[IA] THEN
INS←INSLEV[IA]←-RLEV;
PLMAP[IA,IB]←PLND;
IF ¬LFCHCK THEN
BEGIN
QTRC(CL&"L.f.-check failed");
IF ¬(INSLEV[IA]←INSLEV[IA]-INS)
THEN PLMAP[IA,IB]←0;
GO OU0
END;
LLEV[IA,IB]←RLEV;
PVMAP[VPR]←VSC;
CLEVER(VSC,1007,0);
WEIGHV(VSC,XVCOR[VSC],YVCOR[VSC],RL);
LOOP(IG,1,PLIN,1)
IF LLEV[IG,0]=RLEV∨LLEV[IG,1]=RLEV THEN
PARUP(IG);
IF MAPTRC LAND 4 THEN
UPPDAL((MAPTRC LAND '10)*
(1-2*(MAPTRC LAND 1)));
VLEV[VPR]←RLEV;
MPORDS[RLEV]←ID;
MAPIS[RLEV]←MAPI;
RLEV←RLEV+1;
QTRC(CL&"Recursive branch, new level = "&
CVS(RLEV)&CL);
MPORD←1-(RLEV>3);
GO RULS
END
END "LP1"
END;
_ * * * * * CENTRAL LOOP ENDS * * * * *;
IF ¬RUL THEN
BEGIN
RUL←1;
QTRC(CL&"C-mappings"&CL);
MPORD←2;
GO RULS
END;
IF ¬PARCHK THEN BEGIN DTRC("NO PARTIAL"); GO BU END;
_ MAPREC cont;
_ When we get here, we have a consistent partial mapping.
Exit if complete. Otherwise, if it is the best so far
then memorize it and back up to see if we can do better.;
QTRC(CL&"Partial completion evaluation: ");
IF MAPTRC LAND '20 THEN
UPPDAL((MAPTRC LAND '40)*(1-2*(MAPTRC LAND 5)));
_ First classify the elements into evaluation categories.;
CLEVA;
_ Now check if this mapping is a new maximum, and if so then save it.
If the mapping is a complete, we then exit, otherwise continue.;
SCORE;
IF INSUF THEN BEGIN QTRC(CL&"Insufficient mapping"&CL); GO BU END;
IF CMPL+1
∧(CMPLO∧¬CMPL
∨¬(CMPL XOR CMPLO)
∧SCO≤PARTS[CMPIND,0] LAND '777777777) THEN
BEGIN QTRC("Not maximum partial"&CL); GO BU END;
_ We have a new maximal mapping. Save it in PARTS.;
QTRC(CL&"Maximum partial"&CL); CMPLO←CMPL;
IRET←0;
PARTS[CMPIND,0]←(PROT LSH 3 LOR (1+CMPL)) LSH 27 LOR SCO;
LOOP(IG,1,PLIN,1) PARTS[CMPIND,IG]←0;
_ Delete copied insertions for previously best partial.;
LOOP(IG,1,MAXNOL,1)
IF (N1←LCRL(IG))=1004∨CMPL=-1∧N1=1005 THEN LINDL(IG,0);
_ MAPREC cont;
_ While saving current best partial, copy inserted lines at
LCREDE=1004.;
LOOP(IG,1,PLIN,1)
BEGIN
IF (N1←((V1←PLMAP[IG,0]) MAX (V2←PLMAP[IG,1])))
∧N1≠'7777
∧LCRV(N1)=1002 THEN
IF CMPL=-1 THEN LCREDE[N1←(N1+1)%2]←LCREDE[N1]+2 ELSE
BEGIN
IF V1 THEN V1←2*IFREEL-(V1 LAND 1);
IF V2 THEN V2←2*IFREEL-(V2 LAND 1);
LINSET(LVERCO[N2←N1+(N1 LAND 1)-1]
,LVERCO[LVOPP(N2)]
,XLCOR[N2]
,YLCOR[N2]
,XLCOR[N2←LVOPP(N2)]
,YLCOR[N2]
,1004,0)
END;
PARTS[CMPIND,IC←(IG+2)%3]←
PARTS[CMPIND,IC]
LOR (((IF V1 THEN V1 ELSE V2) LAND '1777)
LOR (IF V1∧V2∨¬N1 THEN 0 ELSE
IF V1 THEN '2000 ELSE '4000))
LSH (12*(3*IC-IG))
END;
_ Mapping is saved. See whether it is complete or not,
and branch accordingly.;
IF ¬(CMPL+1) THEN BEGIN IRET←1; GO OU END;
BU: _ Backup (BULEVS+1) recursive level(s).;
IF RLEV-BULEVS≤4 THEN GO OU;
QTRC(CL&"Backup: "QC(RLEV)QC(BULEVS));
WHILE BULEVS≥0 DO
BEGIN
RLEV←RLEV-1;
IF DELREC(1) THEN GO OU;
BULEVS←BULEVS-1
END;
BULEVS←0;
_ Treat next elemental mapping, or try again with the same one,
depending on DELREC-decisions.;
GO RULS;
_ MAPREC cont;
OU: IF IRET≠1 THEN QTRC(CL&"Recursion exhausted - ");
IF CMPLO THEN IRET←1;
CASE IRET+1 OF
BEGIN
QTRC("Insufficient mapping"&CL);
QTRC(CL&"Partial mapping"&CL);
QTRC(CL&"Complete mapping"&CL)
END;
_ Before returning, restore the scene and clean up.;
_ NOTE: We might later decide to have a scheme for direct
elimination of "1003-lines", rather than relying on CLUPSC
for their removal.;
LOOP(IA,1,MAXNOL,1)
BEGIN
WHILE (IB←LCRL(IA))=1003∨IB=1007 DO REVIVE(IA);
IF IB=1001 THEN REVIVE(IA) ELSE IF IB=1002 THEN LINDL(IA,0)
END;
LNCRE2←LNCS2;
LNCRE0←LNCS1;
RETURN(IF CMPLO=1 THEN 2 ELSE IRET)
END "MAPREC";
END "MAPS2";